home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / profile.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  16.5 KB  |  521 lines
  1. ;;; -*- Package: Profile -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: profile.lisp,v 1.6 92/02/25 14:17:02 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Description: Simple profiling facility.
  15. ;;;
  16. ;;; Author: Skef Wholey, Rob MacLachlan
  17. ;;;
  18. ;;; Compatibility: Runs in any valid Common Lisp.  Three small implementation-
  19. ;;;   dependent changes can be made to improve performance and prettiness.
  20. ;;;
  21. ;;; Dependencies: The macro Quickly-Get-Time and the function
  22. ;;;   Required-Arguments should probably be tailored to the implementation for
  23. ;;;   the best results.  They will default to working, albeit inefficent, forms
  24. ;;;   in non-CMU implementations.  The Total-Consing macro is used to profile
  25. ;;;   consing: in unknown implementations 0 will be used.
  26. ;;;   See the "Implementation Parameters" section.
  27. ;;;
  28. ;;; Note: a timing overhead factor is computed when REPORT-TIME is first
  29. ;;; called.  This will be incorrect if profiling code is run in a different
  30. ;;; environment than the first call to REPORT-TIME.  For example, saving a core
  31. ;;; image on a high performance machine and running it on a low performance one
  32. ;;; will result in use of an erroneously small timing overhead factor.  In CMU
  33. ;;; CL, this cache is invalidated when a core is saved.
  34. ;;;
  35. (in-package "PROFILE")
  36.  
  37. (export '(*timed-functions* profile unprofile report-time reset-time))
  38.  
  39.  
  40. ;;;; Implementation dependent interfaces:
  41.  
  42.  
  43. (progn
  44.   #-cmu
  45.   (eval-when (compile eval)
  46.     (warn
  47.      "You may want to supply an implementation-specific ~
  48.      Quickly-Get-Time function."))
  49.  
  50.   (defconstant quick-time-units-per-second internal-time-units-per-second)
  51.   
  52.   (defmacro quickly-get-time ()
  53.     `(the time-type (get-internal-run-time))))
  54.  
  55.  
  56. ;;; The type of the result from quickly-get-time.
  57. #+cmu
  58. (deftype time-type () '(unsigned-byte 29))
  59. #-cmu
  60. (deftype time-type () 'unsigned-byte)
  61.  
  62.  
  63. ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
  64. ;;; number of required arguments, and use &rest to capture only non-required
  65. ;;; arguments.  The function Required-Arguments returns two values: the first
  66. ;;; is the number of required arguments, and the second is T iff there are any
  67. ;;; non-required arguments (e.g. &optional, &rest, &key).
  68.  
  69. #+cmu (progn
  70. (defun required-arguments-aux (name function)
  71.   (let ((type (kernel:%function-header-type function)))
  72.     (typecase type
  73.       (cons
  74.        (let* ((args (cadr type))
  75.           (pos (position-if
  76.             #'(lambda (x)
  77.             (and (symbolp x)
  78.                  (let ((name (symbol-name x)))
  79.                    (and (>= (length name) 1)
  80.                     (char= (schar name 0) #\&)))))
  81.             args)))
  82.      (if pos
  83.          (values pos t)
  84.          (values (length args) nil))))
  85.       (t
  86.        (warn "No argument count information available for:~%  ~S~@
  87.           Allow for &rest arg consing."
  88.          name)
  89.        (values 0 t)))))
  90.  
  91. (defun required-arguments (name)
  92.   (let* ((function (fdefinition name)))
  93.     (case (kernel:get-type function)
  94.       (#.vm:function-header-type (required-arguments-aux name function))
  95.       ((#.vm:closure-header-type #.vm:funcallable-instance-header-type)
  96.        (required-arguments-aux name (kernel:%closure-function function)))
  97.       (t
  98.        (values 0 t)))))
  99.  
  100. ); #+cmu progn
  101.  
  102. #-cmu
  103. (progn
  104.  (eval-when (compile eval)
  105.    (warn
  106.     "You may want to add an implementation-specific Required-Arguments function."))
  107.  (eval-when (load eval)
  108.    (defun required-arguments (name)
  109.      (declare (ignore name))
  110.      (values 0 t))))
  111.  
  112.  
  113.  
  114. ;;; The Total-Consing macro is called to find the total number of bytes consed
  115. ;;; since the beginning of time.
  116.  
  117. #+cmu
  118. (defmacro total-consing () '(the consing-type (ext:get-bytes-consed)))
  119.  
  120. #-cmu
  121. (progn
  122.   (eval-when (compile eval)
  123.     (warn "No consing will be reported unless a Total-Consing function is ~
  124.            defined."))
  125.  
  126.   (defmacro total-consing () '0))
  127.  
  128.  
  129. ;;; The type of the result of TOTAL-CONSING.
  130. #+cmu
  131. (deftype consing-type () '(unsigned-byte 29))
  132. #-cmu
  133. (deftype consing-type () 'unsigned-byte)
  134.  
  135.  
  136. ;;;; Global data structures:
  137.  
  138. (defvar *timed-functions* ()
  139.   "List of functions that are currently being timed.")
  140.  
  141. ;;; We associate a PROFILE-INFO structure with each profiled function name.
  142. ;;; This holds the functions that we call to manipulate the closure which
  143. ;;; implements the encapsulation.
  144. ;;;
  145. (defvar *profile-info* (make-hash-table :test #'equal))
  146. (defstruct profile-info
  147.   (name nil)
  148.   (old-definition (error "Required keyword arg not supplied.") :type function)
  149.   (new-definition (error "Required keyword arg not supplied.") :type function)
  150.   (read-time (error "Required keyword arg not supplied.") :type function)
  151.   (reset-time (error "Required keyword arg not supplied.") :type function))
  152.  
  153. ;;; PROFILE-INFO-OR-LOSE  --  Internal
  154. ;;;
  155. (defun profile-info-or-lose (name)
  156.   (or (gethash name *profile-info*)
  157.       (error "~S is not a profiled function." name)))
  158.  
  159.  
  160. ;;; We keep around a bunch of functions that make encapsulations, one of each
  161. ;;; (min-args . optional-p) signature we have encountered so far.  We also
  162. ;;; precompute a bunch of encapsulation functions.
  163. ;;;
  164. (defvar *existing-encapsulations* (make-hash-table :test #'equal))
  165.  
  166.  
  167. ;;; These variables are used to subtract out the time and consing for recursive
  168. ;;; and other dynamically nested profiled calls.  The total resource consumed
  169. ;;; for each nested call is added into the appropriate variable.  When the
  170. ;;; outer function returns, these amounts are subtracted from the total.
  171. ;;;
  172. (defvar *enclosed-time* 0)
  173. (defvar *enclosed-consing* 0)
  174. (defvar *enclosed-profilings* 0)
  175. (proclaim '(type time-type *enclosed-time*))
  176. (proclaim '(type consing-type *enclosed-consing*))
  177. (proclaim '(fixnum *enclosed-profilings*))
  178.  
  179.  
  180. ;;; The number of seconds a bare function call takes.  Factored into the other
  181. ;;; overheads, but not used for itself.
  182. ;;;
  183. (defvar *call-overhead*)
  184.  
  185. ;;; The number of seconds that will be charged to a profiled function due to
  186. ;;; the profiling code.
  187. (defvar *internal-profile-overhead*)
  188.  
  189. ;;; The number of seconds of overhead for profiling that a single profiled call
  190. ;;; adds to the total runtime for the program.
  191. ;;;
  192. (defvar *total-profile-overhead*)
  193.  
  194. (proclaim '(single-float *call-overhead* *internal-profile-overhead*
  195.              *total-profile-overhead*))
  196.  
  197.  
  198. ;;;; Profile encapsulations:
  199.  
  200. (eval-when (compile load eval)
  201.  
  202. ;;; MAKE-PROFILE-ENCAPSULATION  --  Internal
  203. ;;;
  204. ;;;    Return a lambda expression for a function that (when called with the
  205. ;;; function name) will set up that function for profiling.
  206. ;;;
  207. ;;; A function is profiled by replacing its definition with a closure created
  208. ;;; by the following function.  The closure records the starting time, calls
  209. ;;; the original function, and records finishing time.  Other closures are used
  210. ;;; to perform various operations on the encapsulated function.
  211. ;;;
  212. (defun make-profile-encapsulation (min-args optionals-p)
  213.   (let ((required-args ()))
  214.     (dotimes (i min-args)
  215.       (push (gensym) required-args))
  216.     `(lambda (name)
  217.        (let* ((time 0)
  218.           (count 0)
  219.           (consed 0)
  220.           (profile 0)
  221.           (old-definition (fdefinition name)))
  222.      (declare (type time-type time) (type consing-type consed)
  223.           (fixnum count))
  224.      (pushnew name *timed-functions*)
  225.  
  226.      (setf (fdefinition name)
  227.            #'(lambda (,@required-args
  228.               ,@(if optionals-p
  229.                 `(&rest optional-args)))
  230.            (incf count)
  231.            (let ((time-inc 0) (cons-inc 0) (profile-inc 0))
  232.              (declare (type time-type time-inc)
  233.                   (type consing-type cons-inc)
  234.                   (fixnum profile-inc))
  235.              (multiple-value-prog1
  236.              (let ((start-time (quickly-get-time))
  237.                    (start-consed (total-consing))
  238.                    (*enclosed-time* 0)
  239.                    (*enclosed-consing* 0)
  240.                    (*enclosed-profilings* 0))
  241.                (multiple-value-prog1
  242.                    ,(if optionals-p
  243.                     `(apply old-definition
  244.                         ,@required-args optional-args)
  245.                     `(funcall old-definition ,@required-args))
  246.                  (setq time-inc (- (quickly-get-time) start-time))
  247.                  (setq cons-inc (- (total-consing) start-consed))
  248.                  (setq profile-inc *enclosed-profilings*)
  249.                  (incf time
  250.                    (the time-type
  251.                     (- time-inc *enclosed-time*)))
  252.                  (incf consed
  253.                    (the consing-type
  254.                     (- cons-inc *enclosed-consing*)))
  255.                  (incf profile profile-inc)))
  256.                (incf *enclosed-time* time-inc)
  257.                (incf *enclosed-consing* cons-inc)
  258.                (incf *enclosed-profilings*
  259.                  (the fixnum (1+ profile-inc)))))))
  260.      
  261.      (setf (gethash name *profile-info*)
  262.            (make-profile-info
  263.         :name name
  264.         :old-definition old-definition
  265.         :new-definition (fdefinition name)
  266.         :read-time
  267.         #'(lambda ()
  268.             (values count time consed profile))
  269.         :reset-time
  270.         #'(lambda ()
  271.             (setq count 0)
  272.             (setq time 0)
  273.             (setq consed 0)
  274.             (setq profile 0)
  275.             t)))))))
  276.  
  277. ); EVAL-WHEN (COMPILE LOAD EVAL)
  278.  
  279.  
  280. ;;; Precompute some encapsulation functions:
  281. ;;;
  282. (eval-when (compile eval)
  283.   (defconstant precomputed-encapsulations 8))
  284. ;;;
  285. (macrolet ((frob ()
  286.          (let ((res ()))
  287.            (dotimes (i precomputed-encapsulations)
  288.          (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
  289.                   #',(make-profile-encapsulation i nil))
  290.                res)
  291.          (push `(setf (gethash '(,i . t) *existing-encapsulations*)
  292.                   #',(make-profile-encapsulation i t))
  293.                res))
  294.            `(progn ,@res))))
  295.   (frob))
  296.  
  297.  
  298.  
  299. ;;; Interfaces:
  300.  
  301. ;;; PROFILE-1-FUNCTION  --  Internal
  302. ;;;
  303. ;;;    Profile the function Name.  If already profiled, unprofile first.
  304. ;;;
  305. (defun profile-1-function (name)
  306.   (cond ((fboundp name)
  307.      (when (gethash name *profile-info*)
  308.        (warn "~S already profiled, so unprofiling it first." name)
  309.        (unprofile-1-function name))
  310.      (multiple-value-bind (min-args optionals-p)
  311.                   (required-arguments name)
  312.        (funcall (or (gethash (cons min-args optionals-p)
  313.                  *existing-encapsulations*)
  314.             (setf (gethash (cons min-args optionals-p)
  315.                        *existing-encapsulations*)
  316.                   (compile nil (make-profile-encapsulation
  317.                         min-args optionals-p))))
  318.             name)))
  319.     (t
  320.      (warn "Ignoring undefined function ~S." name))))
  321.  
  322.  
  323. ;;; PROFILE  --  Public
  324. ;;;
  325. (defmacro profile (&rest names)
  326.   "PROFILE Name*
  327.   Wraps profiling code around the named functions.  As in TRACE, the names are
  328.   not evaluated.  If a function is already profiled, then unprofile and
  329.   reprofile (useful to notice function redefinition.)  If a name is undefined,
  330.   then we give a warning and ignore it.  See also UNPROFILE, REPORT-TIME and
  331.   RESET-TIME."
  332.   `(progn
  333.      ,@(mapcar #'(lambda (name)
  334.            `(profile-1-function ',name))
  335.            names)
  336.      (values)))
  337.  
  338.  
  339. ;;; UNPROFILE  --  Public
  340. ;;;
  341. (defmacro unprofile (&rest names)
  342.   "Unwraps the profiling code around the named functions.  Names defaults to
  343.   the list of all currently profiled functions."
  344.   `(dolist (name ,(if names `',names '*timed-functions*) (values))
  345.      (unprofile-1-function name)))
  346.  
  347.  
  348. ;;; UNPROFILE-1-FUNCTION  --  Internal
  349. ;;;
  350. (defun unprofile-1-function (name)
  351.   (let ((info (profile-info-or-lose name)))
  352.     (remhash name *profile-info*)
  353.     (setq *timed-functions*
  354.       (delete name *timed-functions*
  355.           :test #'equal))
  356.     (if (eq (fdefinition name) (profile-info-new-definition info))
  357.     (setf (fdefinition name) (profile-info-old-definition info))
  358.     (warn "Preserving current definition of redefined function ~S."
  359.           name))))
  360.  
  361.  
  362. (defmacro report-time (&rest names)
  363.   "Reports the time spent in the named functions.  Names defaults to the list of
  364.   all currently profiled functions."
  365.   `(%report-times ,(if names `',names '*timed-functions*)))
  366.  
  367.  
  368. (defstruct (time-info
  369.         (:constructor make-time-info (name calls time consing)))
  370.   name
  371.   calls
  372.   time
  373.   consing)
  374.  
  375.  
  376. ;;; COMPENSATE-TIME  --  Internal
  377. ;;;
  378. ;;;    Return our best guess for the run time in a function, subtracting out
  379. ;;; factors for profiling overhead.  We subtract out the internal overhead for
  380. ;;; each call to this function, since the internal overhead is the part of the
  381. ;;; profiling overhead for a function that is charged to that function.
  382. ;;;
  383. ;;;    We also subtract out a factor for each call to a profiled function
  384. ;;; within this profiled function.  This factor is the total profiling overhead
  385. ;;; *minus the internal overhead*.  We don't subtract out the internal
  386. ;;; overhead, since it was already subtracted when the nested profiled
  387. ;;; functions subtracted their running time from the time for the enclosing
  388. ;;; function.
  389. ;;;
  390. (defun compensate-time (calls time profile)
  391.   (let ((compensated
  392.      (- (/ (float time) (float quick-time-units-per-second))
  393.         (* *internal-profile-overhead* (float calls))
  394.         (* (- *total-profile-overhead* *internal-profile-overhead*)
  395.            (float profile)))))
  396.     (if (minusp compensated) 0.0 compensated)))
  397.  
  398.  
  399. (defun %report-times (names)
  400.   (unless (boundp '*call-overhead*)
  401.     (compute-time-overhead))
  402.   (let ((info ())
  403.     (no-call ()))
  404.     (dolist (name names)
  405.       (let ((pinfo (profile-info-or-lose name)))
  406.     (unless (eq (fdefinition name)
  407.             (profile-info-new-definition pinfo))
  408.       (warn "Function ~S has been redefined, so times may be inaccurate.~@
  409.              PROFILE it again to record calls to the new definition."
  410.         name))
  411.     (multiple-value-bind
  412.         (calls time consing profile)
  413.         (funcall (profile-info-read-time pinfo))
  414.       (if (zerop calls)
  415.           (push name no-call)
  416.           (push (make-time-info name calls
  417.                     (compensate-time calls time profile)
  418.                     consing)
  419.             info)))))
  420.     
  421.     (setq info (sort info #'>= :key #'time-info-time))
  422.  
  423.     (format *trace-output*
  424.         "~&  Seconds  |  Consed   |  Calls  |  Sec/Call  |  Name:~@
  425.            ------------------------------------------------------~%")
  426.  
  427.     (let ((total-time 0.0)
  428.       (total-consed 0)
  429.       (total-calls 0))
  430.       (dolist (time info)
  431.     (incf total-time (time-info-time time))
  432.     (incf total-calls (time-info-calls time))
  433.     (incf total-consed (time-info-consing time))
  434.     (format *trace-output*
  435.         "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%"
  436.         (time-info-time time)
  437.         (time-info-consing time)
  438.         (time-info-calls time)
  439.         (/ (time-info-time time) (float (time-info-calls time)))
  440.         (time-info-name time)))
  441.       (format *trace-output*
  442.           "------------------------------------------------------~@
  443.           ~10,3F | ~9:D | ~7:D |            | Total~%"
  444.           total-time total-consed total-calls)
  445.  
  446.       (format *trace-output*
  447.           "~%Estimated total profiling overhead: ~4,2F seconds~%"
  448.           (* *total-profile-overhead* (float total-calls))))
  449.  
  450.     (when no-call
  451.       (format *trace-output*
  452.           "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
  453.           (sort no-call #'string< :key #'symbol-name)))
  454.     (values)))
  455.  
  456.  
  457. (defmacro reset-time (&rest names)
  458.   "Resets the time counter for the named functions.  Names defaults to the list
  459.   of all currently profiled functions."
  460.   `(%reset-time ,(if names `',names '*timed-functions*)))
  461.  
  462. (defun %reset-time (names)
  463.   (dolist (name names)
  464.     (funcall (profile-info-reset-time (profile-info-or-lose name))))
  465.   (values))
  466.  
  467.  
  468. ;;;; Overhead computation.
  469.  
  470. ;;; We average the timing overhead over this many iterations.
  471. ;;;
  472. (defconstant timer-overhead-iterations 5000)
  473.  
  474.  
  475. ;;; COMPUTE-TIME-OVERHEAD-AUX  --  Internal
  476. ;;;
  477. ;;;    Dummy function we profile to find profiling overhead.  Declare
  478. ;;; debug-info to make sure we have arglist info.
  479. ;;;
  480. (proclaim '(notinline compute-time-overhead-aux))
  481. (defun compute-time-overhead-aux (x)
  482.   (declare (ext:optimize-interface (debug-info 2)))
  483.   (declare (ignore x)))
  484.  
  485.  
  486. ;;; COMPUTE-TIME-OVERHEAD  --  Internal
  487. ;;;
  488. ;;;    Initialize the profiling overhead variables.
  489. ;;;
  490. (defun compute-time-overhead ()
  491.   (macrolet ((frob (var)
  492.            `(let ((start (quickly-get-time))
  493.               (fun (symbol-function 'compute-time-overhead-aux)))
  494.           (dotimes (i timer-overhead-iterations)
  495.             (funcall fun fun))
  496.           (setq ,var
  497.             (/ (float (- (quickly-get-time) start))
  498.                (float quick-time-units-per-second)
  499.                (float timer-overhead-iterations))))))
  500.     (frob *call-overhead*)
  501.     
  502.     (unwind-protect
  503.     (progn
  504.       (profile compute-time-overhead-aux)
  505.       (frob *total-profile-overhead*)
  506.       (decf *total-profile-overhead* *call-overhead*)
  507.       (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux)))
  508.         (multiple-value-bind (calls time)
  509.                  (funcall (profile-info-read-time pinfo))
  510.           (declare (ignore calls))
  511.           (setq *internal-profile-overhead*
  512.             (/ (float time)
  513.                (float quick-time-units-per-second)
  514.                (float timer-overhead-iterations))))))
  515.       (unprofile compute-time-overhead-aux))))
  516.  
  517. #+cmu
  518. (pushnew #'(lambda ()
  519.          (makunbound '*call-overhead*))
  520.      ext:*before-save-initializations*)
  521.